home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / ada / adaed-1.11 / adaed-1 / Adaed-1.11.0a / 2.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-02-07  |  7.3 KB  |  233 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9. #include "hdr.h"
  10. #include "vars.h"
  11. #include "libhdr.h"
  12. #include "dclmapprots.h"
  13. #include "libprots.h"
  14. #include "errmsgprots.h"
  15. #include "miscprots.h"
  16. #include "smiscprots.h"
  17. #include "setprots.h"
  18. #include "chapprots.h"
  19.  
  20. void process_pragma(Node node)                                /*;process_pragma*/
  21. {
  22.     /* This arbitrarily extensible procedure  processes pragma declarations.
  23.      * The name  of the  pragma  determines the way     in which the  args  are
  24.      * processed. If no meaning has been attached to a pragma name, the user
  25.      * is notified, and the pragma is ignored.
  26.      */
  27.  
  28.     Node    id_node, arg_list_node, arg_node, i_node, e_node, arg1, arg2;
  29.     Node    priority, marker_node, type_node;
  30.     char    *id;
  31.     Tuple    args, arg_list;
  32.     Symbol    proc_name, p_type, id_sym;
  33.     int        nat, exists, newnat;
  34.     Fortup    ft1;
  35.     Forset    fs1;
  36.  
  37.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : process_pragma(node) ");
  38.  
  39.     id_node = N_AST1(node);
  40.     arg_list_node = N_AST2(node);
  41.     id = N_VAL(id_node);
  42.     arg_list = N_LIST(arg_list_node);
  43.     /*aix := []; */ /* Most pragmas generate no code.*/
  44.     if (is_empty(arg_list)) {    /* pragma with no parameters */
  45. #ifdef ERRNUM
  46.         str_errmsgn(129, id, 130, node);
  47. #else
  48.         errmsg_str("Format error in pragma", id, "Appendices B, F", node);
  49. #endif
  50.     }
  51.     else {
  52.         /* Process list of arguments. */
  53.         args = tup_new(0);
  54.         FORTUP(arg_node = (Node), arg_list, ft1);
  55.             i_node = N_AST1(arg_node);
  56.             e_node = N_AST2(arg_node);
  57.             adasem(e_node);
  58.             /* For now, disregard named associations.*/
  59.             args = tup_with(args, (char *) e_node);
  60.         ENDFORTUP(ft1);
  61.  
  62.         if (streq(id, "IO_INTERFACE") ) {
  63.             /* Current interface to predefined procedures (e.g. text_io).
  64.              * The pragma makes up the body of a predefined procedure.
  65.              * This body is formatted into a single tuple :
  66.              *
  67.              *        [ io_subprogram, marker , name1, name2...]
  68.              *
  69.              * where the marker is the  second argument  of the  pragma. This
  70.              * marker is  used as an     internal switch by the tio interpreter.
  71.              * The remaining components of  the tuple are the unique names of
  72.              * the formal parameters of the procedure.The pragma must follow
  73.              * immediately the procedure spec to which it applies. The pragma
  74.              * then supplies the body for it.
  75.              */
  76.             arg1 = (Node) args[1];
  77.             /* The first argument in the pragma list is a string in the case
  78.              * of overloadable operators used in the CALENDAR package.
  79.              */
  80.             if (N_KIND(arg1) == as_string_literal)
  81.                 id = N_VAL(arg1);
  82.             else
  83.                 id = N_VAL(N_AST1(arg1));
  84.             /* assert exists proc_name in overloads(declared(scope_name)(id))
  85.              *  | rmatch(nature(proc_name), '_spec') /= om;
  86.              */
  87.             exists = FALSE;
  88.             FORSET(proc_name = (Symbol),
  89.               OVERLOADS(dcl_get(DECLARED(scope_name), id)), fs1);
  90.                 nat = NATURE(proc_name);
  91.                 if (nat == na_procedure_spec  || nat == na_function_spec
  92.                   || nat == na_task_obj_spec || nat == na_generic_procedure_spec
  93.                   || nat == na_generic_function_spec 
  94.                   || nat == na_generic_package_spec) {
  95.                     exists = TRUE;
  96.                     break;
  97.                 }
  98.             ENDFORSET(fs1);
  99.             if (exists == FALSE)
  100.                 warning("subprogram given in pragma not found", node);
  101.             if (nat == na_procedure_spec  ) newnat = na_procedure;
  102.             else if (nat == na_function_spec) newnat = na_function;
  103.             else warning("argument to pragma is not a subprogram", node);
  104.             NATURE(proc_name) = newnat;
  105.             marker_node = N_AST1((Node)args[2]);
  106.             if (tup_size(args) == 3 ) {
  107.                 type_node = (Node)args[3];
  108.                 find_old(type_node);
  109.             }
  110.             else
  111.                 type_node = OPT_NODE;
  112.             N_KIND(node) = as_predef;
  113.             N_UNQ(node) = proc_name;
  114.             /* marker_node is an as_line_no node which carries the numerical 
  115.              * predef code corresponding to the entry in the pragma 
  116.               * IO_INTERFACE. as_line_no was used to simpify having the predef 
  117.              * code converted into a number by the parser and relayed here 
  118.              * as an integer.
  119.              */
  120.             N_VAL(node) = N_VAL(marker_node);
  121.             N_TYPE(node) = (type_node == OPT_NODE)? OPT_NAME : N_UNQ(type_node);
  122.         }
  123.         else if (streq(id, "INTERFACE") ) {
  124.             /* Current interface to C and FORTRAN 
  125.              * The pragma makes up the body of a procedure.
  126.              * This body is formatted into a single tuple :
  127.              *
  128.              *        [language, name]
  129.              *
  130.              * where language is C or FORTRAN and name is the identifier 
  131.              * of the subprogram to be interfaced.
  132.              * This pragma is allowed at the place of a declarative item of
  133.              * the same declarative part or package specification. The pragma 
  134.              * is also allowed for a library unit; in this case, the pragma must
  135.              * appear after the subprogram decl, and before any subsequent
  136.              * compilation unit. 
  137.              */
  138.             arg1 = (Node) args[1];
  139.             /* The 1st arg in the pragma list is an identifier (C or FORTRAN) */
  140.             if (N_KIND(arg1) != as_name) {
  141.                 warning("invalid format for pragma", node);
  142.                 return;
  143.             }
  144.             id = N_VAL(N_AST1(arg1));
  145.             if (!streq(id, "C") && !streq(id, "FORTRAN")) {
  146.                 warning("invalid first argument for pragma", node);
  147.                 return;
  148.             }
  149.  
  150.             arg2 = (Node) args[2];
  151.             /* The 2nd argument in the pragma list is a subprogram identifier */
  152.             if (N_KIND(arg2) != as_name) {
  153.                 warning("invalid format for pragma", node);
  154.                 return;
  155.             }
  156.             id = N_VAL(N_AST1(arg2));
  157.             /* assert exists proc_name in overloads(declared(scope_name)(id))
  158.              *  | rmatch(nature(proc_name), '_spec') /= om;
  159.              */
  160.             exists = FALSE;
  161.             id_sym = dcl_get(DECLARED(scope_name), id);
  162.             if (id_sym == (Symbol)0) {
  163.                 if (NATURE(scope_name)== na_private_part)
  164.                     /* check parent scope, which is scope of visible part */
  165.                     id_sym = dcl_get(DECLARED((Symbol)open_scopes[2]), id);
  166.                 if (id_sym == (Symbol)0) {
  167.                     warning("subprogram given in pragma not found", node);
  168.                     return;
  169.                 }
  170.             }
  171.             FORSET(proc_name = (Symbol), OVERLOADS(id_sym), fs1);
  172.                 nat = NATURE(proc_name);
  173.                 if (nat == na_procedure_spec) {
  174.                     newnat = na_procedure;
  175.                     exists = TRUE;
  176.                 }
  177.                 else if (nat == na_function_spec) {
  178.                     newnat = na_function;
  179.                     exists = TRUE;
  180.                 }
  181.             ENDFORSET(fs1);
  182.             if (!exists) {
  183.                 warning("invalid second argument to pragma", node);
  184.                 return;
  185.             }
  186.  
  187.             NATURE(proc_name) = newnat;
  188.             N_KIND(node) = as_interfaced;
  189.             N_UNQ(node) = proc_name;
  190.             N_AST1(node) = N_AST1(arg1);
  191.         }
  192.  
  193.         else if (streq(id, "PRIORITY")) {
  194.             Unitdecl ud;
  195.             if (tup_size(args) == 1) {
  196.                 ud = unit_decl_get("spSYSTEM");
  197.                 if (ud == (Unitdecl)0 || !in_vis_mods(ud->ud_unam) ) {
  198.                     warning(
  199.       "use of PRIORITY without presence of package SYSTEM is ignored",
  200.                       (Node)args[1]);
  201.                     N_KIND(node) = as_opt;
  202.                     N_AST1(node) = N_AST2(node) = N_AST3(node) = N_AST4(node)
  203.                       = (Node)0;
  204.                     return;
  205.                 }
  206.                 else {
  207.                     p_type = dcl_get_vis(DECLARED(ud->ud_unam), "PRIORITY");
  208.                 }
  209.                 priority = (Node) args[1];
  210.                 check_type(p_type, priority);
  211.                 if (!is_static_expr(priority))
  212.                     warning("Priority must be static", priority);
  213.             }
  214.             else
  215.                 warning("Invalid format for pragma priority", node);
  216.         }
  217.         else if (streq(id, "CONTROLLED")
  218.           || streq(id, "INCLUDE")
  219.           || streq(id, "INLINE")
  220.           || streq(id, "LIST")
  221.           || streq(id, "MEMORY_SIZE")
  222.           || streq(id, "OPTIMIZE")
  223.           || streq(id, "PACK")
  224.           || streq(id, "STORAGE_UNIT")
  225.           || streq(id, "SUPRESS")
  226.           || streq(id, "SYSTEM") ) {
  227.             warning("unsupported pragma", id_node);
  228.         }
  229.         else
  230.             warning("unrecognized pragma", node);
  231.     }
  232. }
  233.